
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  Star Plot Plot Prototype
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmeth star-plot-proto :isnew (dims homals-parent)
 (let* (
        (av (send homals-parent :active-homals-variables))
        (vl (select (send homals-parent :variable-labels) av))
        (ij (get-modal-variable vl))
        (plot (call-next-method dims homals-parent))
       )

 (send self :add-slot 'ij ij)
 (send plot :plot-name (format nil "Star Plot: Variable ~a" (elt vl ij)))
 (send plot :setup dims self)))

(defmeth star-plot-proto :make-point-labels ()
 (let* (
        (homals-parent (send self :homals-parent))
        (plot (send self :plot))
        (ij (send self :ij))
        (n (send homals-parent :n))
        (av (send homals-parent :active-homals-variables))
        (vl (select (send homals-parent :variable-labels) av))
        (ol (send homals-parent :object-labels))
        (k-j (elt (send homals-parent :k-j-list) ij))
       )
  (send plot :point-label (iseq (send plot :num-points))
    (combine (to-string-list ol)
     (mapcar #'(lambda (x) (format nil "~a~a" (elt vl ij) x)) (iseq 1 k-j))))))

(defmeth star-plot-proto :selected-points ()
 (let ((plot (send self :plot))
       (n (send (send self :homals-parent) :n)))
    (send plot :point-selected (iseq n (send plot :num-points)) t)))

(defmeth star-plot-proto :make-lines (&optional point-list)
 (let* ( 
        (homals-parent (send self :homals-parent))
        (plot (send self :plot))
        (y (send homals-parent :y))
        (n (send homals-parent :n))
        (dims (send self :dims))
        (p (length dims))
        (z (break-columns (send homals-parent :z) dims))
        (ij (send self :ij))
        (av (send homals-parent :active-homals-variables))
        (ac (send homals-parent :active-categories))
        (k-j-cumsum (cumsum (cons 0 (send homals-parent :k-j-list))))
        (i-inds (iseq (elt k-j-cumsum ij) (1- (elt k-j-cumsum (1+ ij)))))
        (yy (select y i-inds dims))
        (plotvar (elt (column-list (send homals-parent :data-matrix)) (elt av ij)))
        (gg (make-indicator plotvar (elt ac ij)))
        (aa (matmult gg yy))
        (point-list (if point-list (select point-list (which (< point-list n)))
                                   (iseq n)))
       )
    (dolist (i point-list)
         (send plot :add-lines (mapcar #'(lambda (x)
                            (list (aref z i x) (aref aa i x))) (iseq p))))))


(defmeth star-plot-proto :make-points ()
 (let* ( 
        (homals-parent (send self :homals-parent))
        (plot (send self :plot))
        (y (send homals-parent :y))
        (ij (send self :ij))
        (dims (send self :dims))
        (z (break-columns (send homals-parent :z) dims))
        (k-j-cumsum (cumsum (cons 0 (send homals-parent :k-j-list))))
        (i-inds (iseq (elt k-j-cumsum ij) (1- (elt k-j-cumsum (1+ ij)))))
        (yy (column-list (select y i-inds dims)))
       )

  (send plot :add-points (column-list z))
  (send plot :add-points yy :draw nil)))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  Transformation Plot Prototype
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmeth transformation-plot-proto :isnew (dims homals-parent)
 (let* (
        (av (send homals-parent :active-homals-variables))
        (vl (select (send homals-parent :variable-labels) av))
        (ij (get-modal-variable vl))
        (dims (cons "Original" dims))
        (plot (call-next-method dims homals-parent))
       )
 (send self :add-slot 'ij ij)
 (send plot :plot-name (format nil "Transformation Plot: Variable ~a" 
                      (elt vl ij)))
 (send plot :setup dims self)))



(defmeth transformation-plot-proto :make-point-labels ()
 (let* (
        (homals-parent (send self :homals-parent))
        (plot (send self :plot))
        (ij (send self :ij))
        (av (send homals-parent :active-homals-variables))
        (ac (send homals-parent :active-categories))
        (k-j (elt (send homals-parent :k-j-list) ij))
        (labels (mapcar #'(lambda (x) (format nil "~a~a"
                  (elt (select (send homals-parent :variable-labels) av) ij) x))
                    (iseq 1 k-j)))
       )
  (send plot :point-label (iseq (send plot :num-points)) labels)))

(defmeth transformation-plot-proto :selected-points ()
 (let ((plot (send self :plot)))
  (send plot :point-selected (iseq (send plot :num-points)) t)))


(defmeth transformation-plot-proto :make-lines (&optional point-list)
 (let* (
        (homals-parent (send self :homals-parent))
        (y (send homals-parent :y))
        (plot (send self :plot))
        (dims (send self :dims))
        (ij (send self :ij))
        (ac (send homals-parent :active-categories))
        (cat (sort-data (elt ac ij)))
        (k-j-cumsum (cumsum (cons 0 (send homals-parent :k-j-list))))
        (i-inds (iseq (elt k-j-cumsum ij) (1- (elt k-j-cumsum (1+ ij)))))
        (yy (cons cat (map-elements #'coerce 
                       (column-list (select y i-inds dims)) 'list)))
        (point-list (if point-list point-list (iseq (length (first yy)))))
       )
    (send plot :add-lines 
      (mapcar #'(lambda (x) (select x point-list)) yy))))



(defmeth transformation-plot-proto :make-points ()
 (let* (
        (homals-parent (send self :homals-parent))
        (y (send homals-parent :y))
        (plot (send self :plot))
        (dims (send self :dims))
        (ij (send self :ij))
        (ac (send homals-parent :active-categories))
        (cat (sort-data (elt ac ij)))
        (k-j-cumsum (cumsum (cons 0 (send homals-parent :k-j-list))))
        (i-inds (iseq (elt k-j-cumsum ij) (1- (elt k-j-cumsum (1+ ij)))))
        (yy (map-elements #'coerce 
                       (column-list (select y i-inds dims)) 'list))
       )
   (send plot :add-points (cons cat yy))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  Create Standard Accessor Methods
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmacro normal-accessor (key slot prototype)
`(defmeth ,prototype ,key (&optional (content nil set))
   (when set (setf (slot-value ',slot) content))
   (slot-value ',slot)))

#|(normal-accessor :data data homals-proto)
(normal-accessor :z z homals-proto)
(normal-accessor :p p homals-proto)
(normal-accessor :dialog dialog homals-proto)
(normal-accessor :y y homals-proto)
(normal-accessor :row-ind-list row-ind-list homals-proto)
(normal-accessor :col-ind-list col-ind-list homals-proto)
(normal-accessor :dlist dlist homals-proto) 
(normal-accessor :weights weights homals-proto)
(normal-accessor :weights-samp weights-samp homals-proto)|# ;removed PV
(normal-accessor :sample-row-ind-list sample-row-ind-list homals-proto)
(normal-accessor :sample-col-ind-list sample-col-ind-list homals-proto)
(normal-accessor :dlist-samp dlist-samp homals-proto)
(normal-accessor :z-list z-list homals-proto)


(normal-accessor :homals-parent homals-parent homals-dialog-proto)
(normal-accessor :dialog-items dialog-items homals-dialog-proto)
(normal-accessor :plot-dialog plot-dialog homals-dialog-proto)

(normal-accessor :showing showing homals-plot-dialog-proto)

(normal-accessor :plot-parent plot-parent homals-plot-proto)
(normal-accessor :zoom zoom homals-plot-proto)
(normal-accessor :lines lines homals-plot-proto)
(normal-accessor :plot-name plot-name homals-plot-proto)
(normal-accessor :overlay-list overlay-list homals-plot-proto)


(normal-accessor :plot plot plot-route-proto)
(normal-accessor :ij ij plot-route-proto)
(normal-accessor :dims dims plot-route-proto)
(normal-accessor :homals-parent homals-parent plot-route-proto)
(normal-accessor :len len score-plot-proto)
(normal-accessor :cat-scroll-list cat-scroll-list score-plot-proto)
(normal-accessor :active-var-scroll-list
                 active-var-scroll-list score-plot-proto)
(normal-accessor :passive-var-scroll-list
                 passive-var-scroll-list score-plot-proto)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;   Create Specialized Accessor Methods
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmeth homals-proto :m (&optional (val nil set))
 (if set 
    (setf (slot-value 'm) (array-dimension (send self :data-matrix) 1))
    (slot-value 'm)))
   
(defmeth homals-proto :n (&optional (val nil set))
 (if set
    (setf (slot-value 'n) (array-dimension (send self :data-matrix) 0)) 
    (slot-value 'n)))

#|(defmeth homals-proto :eps-0 (&optional (eps nil set))
 (if set
      (if (pos-numberp eps) 
          (setf (slot-value 'eps-0) (^ 10 (- eps)))
          (setf (slot-value 'eps-0) (^ 10 (- 1))))
      (slot-value 'eps-0)))
      
(defmeth homals-proto :eps-1 (&optional (eps nil set))
 (if set
      (if (pos-numberp eps)
          (setf (slot-value 'eps-1) (^ 10 (- eps)))
          (setf (slot-value 'eps-1) (^ 10 (- 1))))
      (slot-value 'eps-1)))|# 

#|(defmeth homals-proto :active-homals-variables (&optional (file nil set))
 (if set
  (let ((m (send self :m)))
   (if m
    (setf (slot-value 'active-variables)
           (if (> (length file) 0)
               (let ((file-cont (read-data-file file)))
                 (if (and (= m (length file-cont)) (one-or-zero-p file-cont))
                   (select (iseq m) (which (= 1 file-cont)))
                   (progn 
                    (format t
                      "~%~%Wrong Number of Indicators for Variable ~
                             Status in File: ~a ~%~
                       All Variables will be treated as Active~%" file)
                    (iseq m))))
               (iseq m)))))
 (slot-value 'active-variables))) ;removed PV

(defmeth homals-proto :active-categories (&optional (val nil set))
 (if set
  (let ((data (column-list (send self :data-matrix)))
        (active-variables (send self :active-homals-variables)))
   (if data
   (setf (slot-value 'active-categories)
         (mapcar #'(lambda (x)
                    (remove 99 (sort-data (remove-duplicates x :test 'equal))))
                               (select data active-variables)))))
  (slot-value 'active-categories)))

(defmeth homals-proto :category-labels (&optional (val nil set))
 (if set
   (let ((data (column-list (send self :data-matrix))))
      (if data
      (setf (slot-value 'category-labels)
            (mapcar #'(lambda (x) (to-string-list (iseq 1 x)))
                        (mapcar #'number-of-values data)))))
   (slot-value 'category-labels)))

(defmeth homals-proto :object-labels (&optional (file nil set))
 (if set
  (let ((n (send self :n)))
   (if n
    (setf (slot-value 'object-labels)
        (to-string-list
          (if (> (length file) 0)
              (let ((file-cont (read-data-file file)))
                (if (= n (length file-cont))
                    file-cont
                    (progn
                      (format t
                       "~%~%Wrong Number of Object Labels in File: ~a~%~
                        Using default labels 1, 2, . . ., n for Objects~%" file)
                      (iseq 1 n))))
              (iseq 1 n))))))
  (slot-value 'object-labels)))

(defmeth homals-proto :variable-labels (&optional (file nil set))
 (if set
  (let ((m (send self :m)))
   (if m
    (setf (slot-value 'variable-labels)
        (to-string-list
              (if (> (length file) 0)
                  (let ((file-cont (read-data-file file)))
                   (if (= m (length file-cont))
                       file-cont
                       (progn  
                         (format t
                         "~%~%Wrong Number of Variable Labels in File: ~a ~%~
                          Using default labels A, B, C, ..., ~
                          for Variables~%" file)
                         (make-variable-labels (iseq m)))))
                  (make-variable-labels (iseq m)))))))
   (slot-value 'variable-labels)))|#


(defmeth homals-proto :output-file (&optional (file nil set))
  (if set 
   (setf (slot-value 'output-file) (if (> (length file) 0) file nil))
   (slot-value 'output-file)))


(defmacro appending-accessor (key slot prototype)
`(defmeth ,prototype ,key (&optional (content nil set))
 (if set
   (if content
      (setf (slot-value ',slot) (append (slot-value ',slot) (list content)))
      (setf (slot-value ',slot) nil))
   (slot-value ',slot))))

(appending-accessor :k-j-list k-j-list homals-proto)
(appending-accessor :d-m d-m homals-proto)
(appending-accessor :z-list z-list homals-proto)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  Allows Removal/Replacement of Overlays for Saving a Plot Image
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmeth homals-plot-proto :menu-template ()
  (flet ((remove-overlays ()
            (mapcar #'(lambda (x) (send self :delete-overlay x))
                  (send self :overlay-list))
            (if (kind-of-p self homals-3d-plot-proto)
                  (send self :margin 0 0 0 25)
                  (send self :margin 0 0 0 0)))
        (replace-overlays ()
            (let ((wid (send self :text-width "Zoom")))
              (if (kind-of-p self homals-3d-plot-proto)
                    (send self :margin (* 2 wid) 0 0 25)
                    (send self :margin (* 2 wid) 0 0 0))
              (mapcar #'(lambda (x) (send self :add-overlay x))
                 (send self :overlay-list))
              (send self :redraw-overlays))))
    (let ((item (send menu-item-proto
                  :new "Overlays"
                  :action #'(lambda () 
                    (let ((val (slot-value 'mark)))
                     (if val (remove-overlays) (replace-overlays))
                     (setf (slot-value 'mark) (not val)))))))
       (send item :mark 't)
       (append (call-next-method) (list item)))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  Miscelaneous Dialog and helper functions
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmeth homals-list-item-proto :last-click (&optional (val nil set))
  (if set (setf (slot-value 'last-click) val)
          (slot-value 'last-click)))

(defun list-item (p)
 (send homals-list-item-proto :new (to-string-list (iseq 1 p))
                :action #'(lambda (x) (let ((sel (send self :selection)))
                     (when x (if (= sel (send self :last-click))
                                 (send self :selection nil)))
                     (send self :last-click (if sel sel 0))))))

(defun get-dimension-dialog (p &optional num-dims)
  (let* (
         (n (if num-dims num-dims (min 3 p)))
         (ask (send text-item-proto :new 
                (if num-dims
                    "Choose a Dimension:"
                    "Choose one or more Dimensions:")))
         (tell (mapcar #'(lambda (x) (send text-item-proto :new
                            (format nil "Dim ~a:" x))) (iseq 1 n)))
         (vars (mapcar #'(lambda (x) (list-item p)) (iseq 1 n)))
         (ok (send modal-button-proto :new "Ok"
               :action #'(lambda ()
                 (let ((vals (remove nil
                          (mapcar #'(lambda (x) (send x :selection)) vars))))
                     vals))))
         (dialog (send modal-dialog-proto :new
            (cons (list ask)
            (append (list (combine (transpose (list tell vars))))
             (list ok)))
            :title "Dimension Choice Dialog"))
        )
    (mapcar #'(lambda (x y) (send x :selection y)) vars 
                              (if (= 2 n) (list 0 1) (list 0 1 nil)))
    (mapcar #'(lambda (x y) (send x :last-click y)) vars
                              (if (= 2 n) (list 0 1) (list 0 1 0)))
    (send dialog :modal-dialog)))


(defun get-modal-variable (seq)
  (let* (
         (ask-variable (send text-item-proto :new "Variable:"))
         (scroll-list (send list-item-proto :new seq))
         (ok (send modal-button-proto :new "Ok"
                     :action #'(lambda () (send scroll-list :selection))))
         (dialog (send modal-dialog-proto :new
                       (list (list ask-variable scroll-list) (list ok))
                       :title "Variable Choice Dialog"))
        )
    (send scroll-list :selection 0)
    (send dialog :modal-dialog)))


(defun to-string-list (l)
  "Args: l
Converts L to a list of strings."
  (mapcar #'(lambda (x) (format nil "~a" x)) l))

(defun make-dim-labels (dims)
  (if (every #'numberp dims)
      (mapcar #'(lambda (x) (format nil "Dim ~a" x)) (1+ dims))
      (cons (format nil "~a" (first dims))
            (mapcar #'(lambda (x) (format nil "Dim ~a" x)) 
               (1+ (rest dims))))))

(defun make-variable-labels (l)
 (let* ((len (length l))
        (num-rep (ceiling (/ len 52)))
        (str-seq (mapcar #'string (combine (iseq 65 90) (iseq 97 122)))))
   (dotimes (i num-rep)
           (setf str-seq (append str-seq 
              (map-elements #'concatenate 'string
                (format nil "~a" (1+ i))
                (mapcar #'string (combine (iseq 65 90) (iseq 97 122)))))))
    (select (combine str-seq) l)))


(defun break-columns (z dims)
 (apply #'bind-columns (select (column-list z) dims)))

(defun pos-numberp (num)
  (if (numberp num)
      (if (> num 0) t nil) nil))

(defun natural-numberp (dim)
  (if (> (length dim) 0)
      (let ((dimval (read-from-string dim)))
        (if (numberp dimval)
            (if (and (> dimval 0) (= (mod dimval 1) 0))
                dimval)))))


(defun valid-natural-numberp (dim p)
  (if (> (length dim) 0)
      (let ((dimval (read-from-string dim)))
        (if (numberp dimval)
            (if (and (< 0 dimval (1+ p)) (= (mod dimval 1) 0))
                dimval)))))

(defun pad-string (str num)
 (let ((pad-length (- num (length str))))
    (concatenate 'string str (make-string pad-length :intial-element #\ ))))

(defun homals ()
  (let ((homals-object (send homals-proto :new)))
homals-object))

(defun one-or-zero-p (l)
  (not (member nil (mapcar #'(lambda (x) (or (equalp x 1) (equalp x 0))) l))))


(defun bullet ()
'#2a((0 1 1 1 1 1 1 1 1 0)
     (1 0 0 0 0 0 0 0 0 1)
     (1 0 0 1 1 1 1 0 0 1)
     (1 0 1 1 1 1 1 1 0 1)
     (1 0 1 1 1 1 1 1 0 1)
     (1 0 1 1 1 1 1 1 0 1)
     (1 0 1 1 1 1 1 1 0 1)
     (1 0 0 1 1 1 1 0 0 1)
     (1 0 0 0 0 0 0 0 0 1)
     (0 1 1 1 1 1 1 1 1 0)))

(defun empty ()
'#2a((0 1 1 1 1 1 1 1 1 0)
     (1 0 0 0 0 0 0 0 0 1)
     (1 0 0 0 0 0 0 0 0 1)
     (1 0 0 0 0 0 0 0 0 1)
     (1 0 0 0 0 0 0 0 0 1)
     (1 0 0 0 0 0 0 0 0 1)
     (1 0 0 0 0 0 0 0 0 1)
     (1 0 0 0 0 0 0 0 0 1)
     (1 0 0 0 0 0 0 0 0 1)
     (0 1 1 1 1 1 1 1 1 0)))

(defun check ()
'#2a((0 1 1 1 1 1 1 1 1 0)
     (1 1 0 0 0 0 0 0 1 1)
     (1 0 1 0 0 0 0 1 0 1)
     (1 0 0 1 0 0 1 0 0 1)
     (1 0 0 0 1 1 0 0 0 1)
     (1 0 0 0 1 1 0 0 0 1)
     (1 0 0 1 0 0 1 0 0 1)
     (1 0 1 0 0 0 0 1 0 1)
     (1 1 0 0 0 0 0 0 1 1)
     (0 1 1 1 1 1 1 1 1 0)))


;(homals) removed PV

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Computing methods for an ALS iteration.
;;
;; It would be useful to have versions of this in C,
;; and load them dynamically.
;;
;; The same thing is true for the Gram-Schmidt and the Procrustus
;; modules below, because that is where most of the computing takes
;; place.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun make-category-quantifications (x g)
  (let* ((d (geninv (column-sums g))))
    (matmult (diagonal d) (matmult (transpose g) x))))

(defun make-discrimination-measures (y g)
  (let* ((d (column-sums g)))
    (/ (matmult (transpose y) (matmult (diagonal d) y)) 
       (array-dimension g 0))))

(defun make-weights (e s)
  (let* ((n (first (array-dimensions e)))
         (m (second (array-dimensions e)))
         (f (column-list e))
         (w (make-list n :initial-element 0)))
    (dotimes (j m)
      (incf w (row-sums (make-indicator (elt f j) (elt s j)))))    
    w
 ))

